home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d26 / cattest.arc / UUENC.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-01  |  6KB  |  198 lines
  1. {$A+,B-,D+,E+,F-,I+,L+,N-,O-,R-,S+,V+}
  2. {$M 16384,0,655360}
  3. program uuetest;
  4. Uses Dos,Crt;
  5. procedure uuencode;
  6. {v1.1 Toad Hall Tweak, 9 May 90
  7.  - Converted reserved, other word case to my preferred style.
  8.  - Converted for Turbo Pascal v5.0 compilation ("Uses", etc.)
  9. }
  10.  
  11. CONST
  12.   Header = 'begin';
  13.   Trailer = 'end';
  14.   DefaultMode = '644';
  15.   DefaultExtension = '.uue';
  16.   OFFSET = 32;
  17.   CHARSPERLINE = 60;
  18.   BYTESPERHUNK = 3;
  19.   SIXBITMASK = $3F;
  20. TYPE
  21.   Str80 = STRING[80];
  22. VAR
  23.   Infile: FILE OF Byte;
  24.   Outfile: TEXT;
  25.   Infilename, Outfilename, Mode: Str80;
  26.   lineLength, numbytes, bytesInLine: INTEGER;
  27.   Line: ARRAY [0..59] OF CHAR;
  28.   hunk: ARRAY [0..2] OF Byte;
  29.   chars: ARRAY [0..3] OF Byte;
  30.   size,remaining : longint;  {v1.1 REAL;}
  31.   out_file_OK : Boolean;
  32.   i1 : integer;
  33. {  procedure debug;
  34.     var i: integer;
  35.     procedure writebin(x: byte);
  36.       var i: integer;
  37.       begin
  38.         for i := 1 to 8 do begin
  39.             write ((x and $80) shr 7);
  40.             x := x shl 1
  41.           end;
  42.         write (' ')
  43.       end;
  44.     begin
  45.       for i := 0 to 2 do writebin(hunk[i]);
  46.       writeln;
  47.       for i := 0 to 3 do writebin(chars[i]);
  48.       writeln;
  49.       for i := 0 to 3 do writebin(chars[i] and SIXBITMASK);
  50.       writeln
  51.     end;  }
  52. PROCEDURE Abort (Msg : Str80);
  53.   BEGIN
  54.     WRITELN(Msg);
  55.     {$I-}                 {v1.1}
  56.     CLOSE(Infile);
  57.     CLOSE(Outfile);
  58.     {$I+}                 {v1.1}
  59.     HALT
  60.   END; {of Abort}
  61. PROCEDURE Init;
  62.   PROCEDURE GetFiles;
  63.     VAR
  64.       i : INTEGER;
  65.       TempS : Str80;
  66.       Ch : CHAR;
  67.     BEGIN
  68. (*      IF ParamCount < 1 THEN Abort ('No input file specified.');
  69.       Infilename := ParamStr(1);
  70.       {$I-}
  71.       ASSIGN (Infile, Infilename);
  72.       RESET (Infile);
  73.       {$I+}
  74.       IF IOResult > 0 THEN Abort (CONCAT ('Can''t open file ', Infilename));*)
  75.  
  76. (*      size := FileSize(Infile);
  77. {     IF size < 0 THEN size:=size+65536.0; }*)
  78. (* get the number of bytes of data to be encrypted and saved *)
  79.       remaining := size;
  80. (*      WRITE('Uuencoding file ', Infilename);*)
  81. (*      i := POS('.', Infilename);
  82.       IF i = 0
  83.       THEN Outfilename := Infilename
  84.       ELSE Outfilename := COPY (Infilename, 1, PRED(i));
  85.       Mode := DefaultMode;
  86.       { Process 2d cmdline arg (if any).
  87.         It could be a new mode (rather than default "644")
  88.         or it could be a forced output name (rather than
  89.         "infile.uue")
  90.       }
  91.       IF ParamCount > 1                         {got more args}
  92.       THEN FOR i := 2 TO ParamCount DO BEGIN
  93.         TempS := ParamStr(i);
  94.         IF TempS[1] IN ['0'..'9']               {numeric : it's a mode}
  95.         THEN Mode := TempS
  96.         ELSE Outfilename := TempS               {it's output filename}
  97.       END;
  98.       IF POS ('.', Outfilename) = 0       {he didn't give us extension..}
  99.                                           {..so make it ".uue"}
  100.       THEN Outfilename := CONCAT(Outfilename, DefaultExtension); *)
  101.       Outfilename := 'STUDREC.UUE';
  102.       out_file_OK := False;
  103.       repeat
  104.       ASSIGN (Outfile, Outfilename);
  105.       {$I-}
  106.       RESET(Outfile);
  107.       {$I+}
  108.       IF IOResult = 0 THEN BEGIN         {output file exists!}
  109.          i1 := Ord(outfilename[11]);
  110.          OutFileName[11] := CHR(i1);     {system allows uue, uuf, uug etc.}
  111.       end;
  112.       {$I-}
  113.       CLOSE(Outfile);
  114.       IF IOResult <> 0 THEN ;  {v1.1 we don't care}
  115.       REWRITE(Outfile);
  116.       {$I+}
  117.       IF IOResult > 0 THEN Abort(
  118.         CONCAT('Can''t open ', Outfilename,';Major error'))
  119.       else out_file_OK := True;
  120.       until Out_file_OK;
  121.  
  122.     END; {of GetFiles}
  123.   BEGIN {Init}
  124.     GetFiles;
  125.     bytesInLine := 0;
  126.     lineLength := 0;
  127.     numbytes := 0;
  128.     WRITELN (Outfile, Header, ' ', Mode, ' ', Infilename);
  129.   END; {init}
  130. {You'll notice from here on we don't do any error-trapping on disk
  131.  read/writes.  We just let DOS do the job.  Any errors are terminal
  132.  anyway, right?
  133. }
  134. PROCEDURE FlushLine;
  135.   VAR i: INTEGER;
  136.   PROCEDURE WriteOut(Ch: CHAR);
  137.     BEGIN
  138.       IF Ch = ' ' THEN WRITE(Outfile, '`')
  139.                   ELSE WRITE(Outfile, Ch)
  140.     END; {of WriteOut}
  141.   BEGIN {FlushLine}
  142.     {write ('.');}
  143.     WRITE('bytes remaining: ',remaining:7,' (',
  144.           remaining/size*100.0:3:0,'%)',CHR(13));
  145.     WriteOut(CHR(bytesInLine + OFFSET));
  146.     FOR i := 0 TO PRED(lineLength) DO
  147.       WriteOut(Line[i]);
  148.     WRITELN (Outfile);
  149.     lineLength := 0;
  150.     bytesInLine := 0
  151.   END; {of FlushLine}
  152. PROCEDURE FlushHunk;
  153.   VAR i: INTEGER;
  154.   BEGIN
  155.     IF lineLength = CHARSPERLINE THEN FlushLine;
  156.     chars[0] := hunk[0] ShR 2;
  157.     chars[1] := (hunk[0] ShL 4) + (hunk[1] ShR 4);
  158.     chars[2] := (hunk[1] ShL 2) + (hunk[2] ShR 6);
  159.     chars[3] := hunk[2] AND SIXBITMASK;
  160.     {debug;}
  161.     FOR i := 0 TO 3 DO BEGIN
  162.       Line[lineLength] := CHR((chars[i] AND SIXBITMASK) + OFFSET);
  163.       {write(line[linelength]:2);}
  164.       Inc(lineLength);
  165.     END;
  166.     {writeln;}
  167.     Inc(bytesInLine,numbytes);
  168.     numbytes := 0
  169.   END; {of FlushHunk}
  170. PROCEDURE Encode1;
  171.   BEGIN
  172.     IF numbytes = BYTESPERHUNK THEN FlushHunk;
  173.     (*READ (Infile, hunk[numbytes]);*)
  174.     (*move numbytes of internal data to hunk[numbytes] *)
  175.     Dec(remaining);
  176.     Inc(numbytes);
  177.   END; {of Encode1}
  178. PROCEDURE Terminate;
  179.   BEGIN
  180.     IF numbytes > 0 THEN FlushHunk;
  181.     IF lineLength > 0 THEN BEGIN
  182.       FlushLine;
  183.       FlushLine;
  184.     END
  185.     ELSE FlushLine;
  186.     WRITELN (Outfile, Trailer);
  187.     CLOSE (Outfile);
  188.     CLOSE (Infile);
  189.   END; {Terminate}
  190.   BEGIN {uuencode}
  191.     Init;
  192.     WHILE NOT EOF (Infile) DO Encode1;
  193.     Terminate;
  194.     WRITELN;
  195.   END; {uuencode}
  196. begin
  197. end.
  198.